home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / back_end / m68locgen.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  13.4 KB  |  309 lines
  1. (herald (back_end m68locgen)
  2.   (env t (orbit_top defs) (back_end bookkeep)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.                              
  29. (define (generate-set-location node)    ;; cont type-primop value . args
  30.   ((xselect (length (call-args node))
  31.      ((4) generate-set-fixed-accessor)
  32.      ((5) generate-set-vector-elt))
  33.    node))
  34.  
  35.  
  36.  
  37. (define (generate-set-fixed-accessor node)
  38.   (destructure (((#f type value loc) (call-args node)))
  39.     (let* ((prim (leaf-value type))
  40.            (do-it 
  41.             (lambda (access)
  42.               (cond ((and (eq? prim primop/cell-value)
  43.                           (eq? (variable-definition (leaf-value loc)) 'one))
  44.                      (let ((lc (access-value node (leaf-value loc))))
  45.                        (generate-move access lc)
  46.                        (cond ((and (register? lc) (temp-loc (leaf-value loc)))
  47.                               => (lambda (lc)
  48.                                    (set (temp-node lc) nil)
  49.                                    (set (temp-loc (leaf-value loc)) nil))))))
  50.                     (else
  51.                      (let ((reg (->register 'pointer node (leaf-value loc) '*)))
  52.                        (generate-move access
  53.                              (reg-offset reg (primop.location-specs prim)))))))))
  54.       (cond ((lambda-node? value)
  55.              (let ((access (access/make-closure node value)))
  56.                (if access (protect-access access) (lock AN))
  57.                (do-it (if access access AN))
  58.                (if access (release-access access) (unlock AN))))
  59.             (else
  60.              (let ((access (access-with-rep node (leaf-value value) 'rep/pointer)))
  61.                (protect-access access)                         
  62.                (do-it access)
  63.                (release-access access)))))))
  64.  
  65.  
  66.                     
  67. (define (generate-set-vector-type-length node)
  68.   (destructure (((#f vec val) (call-args node)))
  69.     (let ((reg (->register 'pointer node (leaf-value vec) '*))
  70.           (val (leaf-value val)))
  71.       (lock reg)
  72.       (let ((scratch (get-register 'scratch node '*)))
  73.         (cond ((variable? val)               
  74.                (generate-move (access-value node val) scratch)
  75.                (emit m68/asl .l 
  76.                      (machine-num (if (eq? (variable-rep val) 'rep/pointer) 6 8))
  77.                      scratch))
  78.               (else 
  79.                (emit m68/move .l (machine-num (fixnum-ashl val 8)) scratch)))
  80.         (emit m68/move .b (reg-offset reg 1) scratch)
  81.         (emit m68/move .l scratch (reg-offset reg -2))
  82.         (unlock reg)))))
  83.                
  84.                                                      
  85.                     
  86. (define (generate-set-vector-elt node)
  87.   (destructure (((#f type value loc idex) (call-args node)))
  88.     (let ((idex (leaf-value idex))
  89.           (rep (primop.rep-wants (leaf-value type)))
  90.       (reg (->register 'pointer node (leaf-value loc) '*)))
  91.       (lock reg)
  92.       (cond ((eq? rep 'rep/pointer)
  93.              (let* ((access (if (lambda-node? value)
  94.                                 (access/make-closure node value)
  95.                                 (access-value node (leaf-value value))))
  96.                     (value-acc (if access access AN)))
  97.                (if access (protect-access access) (lock AN))
  98.                (let* ((i-acc (access-with-rep node idex 'rep/pointer))
  99.                       (i-reg (cond ((register? i-acc) i-acc)
  100.                                    (else
  101.                                     (emit m68/move .l i-acc SCRATCH)
  102.                                     SCRATCH))))
  103.                  (generate-move value-acc (indexer reg tag/extend i-reg))
  104.          (unlock reg)
  105.                  (if access (release-access access) (unlock AN)))))
  106.             (else                                                               
  107.              (let* ((i-acc (access-with-rep node idex 'rep/integer))
  108.                     (i-reg (cond ((register? i-acc) i-acc)
  109.                                  (else
  110.                                   (let ((i (get-register 'scratch node '*)))
  111.                                     (emit m68/move .l i-acc i)
  112.                                     i))))
  113.                     (value (leaf-value value)))
  114.                  (lock i-reg)
  115.                  (cond ((variable? value)                       
  116.                         (let ((acc (access-value node value)))
  117.                           (protect-access acc)
  118.                           (really-rep-convert node acc (variable-rep value)
  119.                                    (indexer reg tag/extend i-reg)
  120.                                    rep)
  121.                           (release-access acc)))
  122.                        (else
  123.                         (really-rep-convert node (value-with-rep value rep)
  124.                                             rep
  125.                                             (indexer reg tag/extend i-reg)
  126.                                             rep)))
  127.                  (unlock i-reg)
  128.                  (unlock reg)))))))
  129.  
  130.                    
  131.                         
  132. (define (generate-contents-location node)
  133.   ((xselect (length (call-args node))
  134.      ((3) generate-fixed-accessor)
  135.      ((4) generate-vector-elt))
  136.    node))
  137.  
  138.  
  139. (define (generate-fixed-accessor node)
  140.   (destructure (((cont type loc) (call-args node)))
  141.    (if (or (leaf-node? cont) (used? (car (lambda-variables cont))))   
  142.        (receive (t-spec t-rep) (continuation-wants cont)
  143.          (let* ((type (leaf-value type))
  144.                 (base (leaf-value loc))
  145.                 (target (get-target-register node t-spec)))
  146.            (cond ((and (eq? type primop/cell-value)
  147.                        (eq? (variable-definition base) 'one))
  148.                   (really-rep-convert node (access-value node base)
  149.                                       'rep/pointer target t-rep))
  150.                  (else
  151.                   (let ((reg (->register 'pointer node base '*)))
  152.                     (really-rep-convert node 
  153.                                (reg-offset reg (primop.location-specs type))
  154.                                'rep/pointer target t-rep))))
  155.            (cond ((reg-node target) 
  156.                   => (lambda (node) (set (register-loc node) nil))))
  157.            (mark-continuation node target))))))
  158.  
  159.  
  160.  
  161.                                                
  162. (define (generate-vector-type-length node)
  163.   (destructure (((cont vec) (call-args node)))
  164.     (receive (t-spec t-rep) (continuation-wants cont)
  165.       (let* ((base (leaf-value vec))
  166.              (target (get-target-register node t-spec))
  167.              (reg (->register 'pointer node base '*))
  168.              (temp (if (eq? (reg-type target) 'scratch) target SCRATCH)))
  169.         (emit m68/move .l (reg-offset reg -2) temp)
  170.         (emit m68/asr .l (machine-num 8) temp)
  171.         (if (eq? t-rep 'rep/pointer)
  172.             (emit m68/asl .l (machine-num 2) temp))
  173.         (generate-move temp target)
  174.         (cond ((reg-node target) 
  175.                => (lambda (node) (set (register-loc node) nil))))
  176.         (mark-continuation node target)))))
  177.  
  178.                                                
  179.  
  180. (define (generate-vector-elt node)
  181.   (destructure (((cont type loc idex) (call-args node)))
  182.     (receive (t-spec t-rep) (continuation-wants cont)
  183.          (let* ((base (leaf-value loc))
  184.             (rep (primop.rep-wants (leaf-value type)))                    
  185.             (idex (leaf-value idex))
  186.             (t-reg (get-target-register node t-spec))
  187.             (reg (->register 'pointer node base '*)))
  188.            (lock reg)
  189.            (cond ((fixnum? idex) 
  190.               (really-rep-convert node 
  191.                       (reg-offset reg (fx+ (if (eq? rep 'rep/pointer)
  192.                                    (fx* idex 4)
  193.                                    idex)
  194.                                    tag/extend))
  195.                       (primop.rep-wants (leaf-value type))
  196.                       t-reg t-rep))
  197.              (else
  198.               (let* ((i-acc (access-with-rep node idex 
  199.                              (if (eq? rep 'rep/pointer)
  200.                              'rep/pointer
  201.                              'rep/integer)))
  202.                  (i-reg (cond ((register? i-acc) i-acc)
  203.                       (else
  204.                        (let ((i (get-register 'scratch node '*)))
  205.                          (emit m68/move .l i-acc i)
  206.                          i)))))
  207.             (really-rep-convert node (indexer reg tag/extend i-reg)
  208.                         rep t-reg t-rep))))
  209.            (unlock reg)
  210.            (cond ((reg-node t-reg) 
  211.               => (lambda (node) (set (register-loc node) nil))))
  212.            (mark-continuation node t-reg)))))
  213.  
  214.  
  215. (define (generate-make-pointer node)
  216.   (destructure (((cont loc idex) (call-args node)))
  217.     (receive (t-spec t-rep) (continuation-wants cont)
  218.       (let ((t-reg (get-target-register node t-spec))
  219.             (reg (->register 'pointer node (leaf-value loc) '*)))
  220.         (lock reg)
  221.         (let* ((i-acc (access-with-rep node (leaf-value idex) 'rep/pointer))
  222.                (i-reg (cond ((register? i-acc) i-acc)
  223.                             (else
  224.                              (let ((i (get-register 'scratch node '*)))
  225.                                (emit m68/move .l i-acc i)
  226.                                i)))))
  227.           (emit m68/lea (indexer reg 4 i-reg) t-reg))
  228.         (unlock reg)
  229.         (cond ((reg-node t-reg) 
  230.                => (lambda (node) (set (register-loc node) nil))))
  231.         (mark-continuation node t-reg)))))
  232.  
  233.  
  234. (define (generate-location-access node)
  235.   ((xselect (length (call-args node))
  236.      ((3) defer-fixed-accessor)
  237.      ((4) defer-vector-elt))
  238.    node))
  239.  
  240. (define (defer-fixed-accessor node)
  241.   (destructure (((cont type loc) (call-args node)))
  242.     (let* ((type (leaf-value type))
  243.            (base (leaf-value loc))
  244.            (reg (->register 'pointer node base '*)))
  245.       (lock reg)
  246.       (set (register-loc (car (lambda-variables cont)))
  247.            (cons reg (primop.location-specs type)))
  248.       (allocate-call (lambda-body cont)))))
  249.  
  250.  
  251.  
  252. (define (defer-vector-elt node)
  253.   (destructure (((cont type loc index) (call-args node)))
  254.     (let* ((base (leaf-value loc))
  255.            (rep (primop.rep-wants (leaf-value type)))
  256.            (index (leaf-value index))
  257.            (reg (->register 'pointer node base '*)))
  258.       (lock reg)                                                            
  259.       (cond ((fixnum? index)
  260.              (set (register-loc (car (lambda-variables cont)))
  261.                   (cons reg (fx+ (if (eq? rep 'rep/pointer)
  262.                                      (fx* 4 index)
  263.                                      index)
  264.                                   tag/extend))))
  265.             (else
  266.              (let* ((i-acc (access-with-rep node index 
  267.                                  (if (eq? rep 'rep/pointer)
  268.                                      'rep/pointer
  269.                                      'rep/integer)))
  270.                     (i-reg (cond ((register? i-acc) i-acc)
  271.                                  (else
  272.                                   (let ((i (get-register 'scratch node '*)))
  273.                                     (emit m68/move .l i-acc i)
  274.                                     i)))))
  275.                (unlock reg)
  276.                (kill-if-dying index node)
  277.                (lock reg)
  278.                (lock i-reg)
  279.                (set (register-loc (car (lambda-variables cont)))
  280.                     (cons (cons reg i-reg) 2)))))
  281.       (allocate-call (lambda-body cont)))))
  282.           
  283.                     
  284.                     
  285. (define (generate-%chdr node)
  286.   (destructure (((#f vec val) (call-args node)))
  287.     (let ((reg (->register 'pointer node (leaf-value vec) '*))
  288.           (val (leaf-value val)))
  289.       (lock reg)                                              
  290.       (cond ((fixnum? val)
  291.              (if (fx= val 1)
  292.                  (emit m68/add .l (machine-num 1) (reg-offset reg offset/string-base))
  293.                  (emit m68/add .l (machine-num val) 
  294.                        (reg-offset reg offset/string-base)))
  295.              (emit m68/sub .l (machine-num (fixnum-ashl val 8))
  296.                    (reg-offset reg -2)))
  297.             (else
  298.              (let* ((n (access-with-rep node val 'rep/integer))
  299.                     (data-reg (if (and (register? n) (dying? val node)) 
  300.                              n
  301.                              SCRATCH)))
  302.                (generate-move n data-reg)
  303.                (emit m68/add .l data-reg (reg-offset reg offset/string-base))
  304.                (emit m68/asl .l (machine-num 8) data-reg)
  305.                (emit m68/sub .l data-reg (reg-offset reg -2)))))
  306.       (unlock reg))))
  307.                
  308.  
  309.